Linux Cubed Series 3: Developer Tools/Linux Cubed Series 3 - Developer Tools.iso/devel/lang/fortran/f2c-stab.9/f2c-stab/f2c-stabs/si-lib.stk

Text File | 1996-03-31 | 13.2 KB | 442 lines

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; si-lib - Library for manipulating system information records (as
;;;          produced by fts-f2si).
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Copyright (c) 1996 Harvey J. Stein <[e-mail]>, and
;;; eventually <[e-mail]>
;;; All Rights Reserved.
;;;
;;; This package is covered by the GNU GPL.  You can freely use and
;;; distribute it as long as it stays under the GNU GPL, and as long as
;;; you distribute all the corresponding source code, and as long as this
;;; message and the above copyright notice remains.

(require "formout")
(require "columnout")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Top level interface
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-reader f-decl)
  "Given a Subroutine Info table F-DECL (as generated by fts-f2si),
writes (to stdout) fortran code for reading in the arguments to the
subroutine defined in F-DECL."
  (header 'reader
      f-decl)
  (dump-reader f-decl)
  (trailer))

(define (make-writer f-decl)
  "Given a Subroutine Info table F-DECL (as generated by fts-f2si),
writes (to stdout) fortran code for writing out the arguments to the
subroutine defined in F-DECL."
  (header 'writer
      f-decl)
  (dump-writer f-decl)
  (trailer))

(define (make-driver f-decl)
  "Given a Subroutine Info table F-DECL (as generated by fts-f2si),
writes (to stdout) fortran code for writing out the arguments to the
subroutine defined in F-DECL."
  (header 'driver
      f-decl)
  (dump-driver f-decl))

(define (make-reader-and-writer si-decl)
"Makes both reader and writer for subroutine described by SI-DECL.
Output is to appropriate files (subname_reader.f and subname_writer.f)."
  (with-output-to-file (format #f "~a_reader.f" (si-subname si-decl))
               (lambda () (make-reader si-decl)))
  (with-output-to-file (format #f "~a_writer.f" (si-subname si-decl))
               (lambda () (make-writer si-decl)))
  (with-output-to-file (format #f "~a_driver.f" (si-subname si-decl))
               (lambda () (make-driver si-decl))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Handling Subroutine Information tables.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; full si record
(define (si-subname f-decl)
  (list-ref f-decl 0))

(define (si-filename f-decl)
  (list-ref f-decl 1))

(define (si-function-type f-decl)
  (list-ref f-decl 2))

(define (si-args f-decl)
  (list-ref f-decl 3))

(define (si-calls f-decl)
  (list-ref f-decl 4))

(define (si-locals f-decl)
  (list-ref f-decl 5))

(define (si-includes f-decl)
  (list-ref f-decl 6))

(define (si-externals f-decl)
  (list-ref f-decl 7))

(define (si-common f-decl)
  (list-ref f-decl 8))

(define (si-params f-decl)
  (list-ref f-decl 9))

;;; si argument block
(define (si-arg-name arg-rec)
  (list-ref arg-rec 0))

(define (si-conditioned-arg-type arg-rec)
  (define screwy-char (string->regexp "\\*\\*"))
  (regexp-replace screwy-char (symbol->string (si-arg-type arg-rec))
           "*(*)"))


(define (si-arg-type arg-rec)
  (list-ref arg-rec 1))

(define (si-arg-dimen arg-rec)
  (if (not (null? (cddr arg-rec)))
      (list-ref arg-rec 2)
      #f))

;;; si include file block
(define (si-incs-file-name inc-rec)
  (list-ref inc-rec 0))

;;; si common block
(define (si-common-name common)
  (list-ref common 0))

(define (si-common-vars common)
  (list-ref common 1))

;;; si parameters
(define (si-param-name param)
  (list-ref param 0))

(define (si-param-value param)
  (list-ref param 1))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Outputting pieces of the FORTRAN code for readers and writers.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Mappings from variable types to reader/writer functions.  Note
;;; that some of the mappings are bogus because certain writters don't
;;; exist and/or don't follow the correct naming conventions.
(define scalar-reader-list
  `((integer    . "pff_rdint")
    (integer*2  . "pff_rdint")
    (integer*4  . "pff_rdint")
    (real       . "pff_rdreal")
    (real*4     . "pff_rdreal")
    (real*8     . "pff_rdreal")
    (logical    . "pff_rdlog")
    (logical*2  . "pff_rdlog")
    (logical*4  . "pff_rdlog")))

(define array-reader-list
  `((integer    . "pff_rdari4")
    (integer*2  . "pff_rdari2")
    (integer*4  . "pff_rdari4")
    (real       . "pff_rdarr4")
    (real*4     . "pff_rdarr4")
    (real*8     . "pff_rdarr8")
    (logical    . "pff_rdarlog4")
    (logical*2  . "pff_rdarlog2")
    (logical*4  . "pff_rdarlog4")))

(define scalar-writer-list
  `((integer    . "pff_wri4")
    (integer*2  . "pff_wri2")
    (integer*4  . "pff_wri4")
    (real       . "pff_wrr4")
    (real*4     . "pff_wrr4")
    (real*8     . "pff_wrr8")
    (logical    . "pff_wrlog4")
    (logical*2  . "pff_wrlog2")
    (logical*4  . "pff_wrlog4")))

(define array-writer-list
  `((integer    . "pff_wrari4")
    (integer*2  . "pff_wrari2")
    (integer*4  . "pff_wrari4")
    (real       . "pff_wrarr4")
    (real*4     . "pff_wrarr4")
    (real*8     . "pff_wrarr8")
    (logical    . "pff_wrarlog4")
    (logical*2  . "pff_wrarlog2")
    (logical*4  . "pff_wrarlog4")))

(define (read/write-fcn-name var-spec scalar-list array-list)
  "Returns the fcn name for reading/writing VAR-SPEC.  SCALAR-LIST
should be an alist matching up types to functions for scalars.
ARRAY-LIST should do the same for arrays."
  (let ((fnam (cond ((and (si-arg-dimen var-spec)
              (= 1 (length (si-arg-dimen var-spec))))
             (assoc (si-arg-type var-spec) array-list))
            ((not (si-arg-dimen var-spec))
             (assoc (si-arg-type var-spec) scalar-list))
            (else #f))))
    (if fnam (cdr fnam) "pff_unknown_guy")))

(define (write-fcn-name var-spec)
  "Returns the fcn name for writing VAR-SPEC."
  (read/write-fcn-name var-spec scalar-writer-list array-writer-list))

(define (read-fcn-name var-spec)
  "Returns the fcn name for reading VAR-SPEC."
  (read/write-fcn-name var-spec scalar-reader-list array-reader-list))

(define (write-dimen-size dim)
  (define split (string->regexp "^([^:]*):(.*)$"))
  (let ((split-pts (split dim)))
    (if split-pts
    (format #f "(~a)-(~a)+1"
        (apply substring dim (list-ref split-pts 2))
        (apply substring dim (list-ref split-pts 1)))
    (format #f "~a" dim))))

(define (write-var var-spec)
  "Writes out ftn code for writing out the value of the variable
described by VAR-SPEC."
  (let ((writer (write-fcn-name var-spec)))
    (case (si-arg-dimen var-spec)
      ;; Scalar
      (#f (format-fortran-w-cont
       #t
       "      CALL ~a(SI_UNIT_NUM, '~a', ~a, ' ', ' ')\n"
       "     +                "
       (left-10 writer)
       (left-10 (si-arg-name var-spec))
       (left-10 (si-arg-name var-spec))))
      (else  (format-fortran-w-cont
          #t
          "      CALL ~a(SI_UNIT_NUM, '~a', ~a, ~a,  ' ', ' ',     5)\n"
          "     +                "
          (left-10 writer)
          (left-10 (si-arg-name var-spec))
          (left-10 (si-arg-name var-spec))
          (left-10 (format #f "INT(~a)"
                   (write-dimen-size
                (car (si-arg-dimen var-spec))))) ; A wild guess...
          )))))

(define (read-var var-spec)
  "Writes out ftn code for reading the value of the variable
described by VAR-SPEC."
  (let ((reader (read-fcn-name var-spec)))
    (case (si-arg-dimen var-spec)
      ;; Scalar
      (#f (format-fortran-w-cont
       #t
       "      ~a = ~a(SI_UNIT_NUM, ' ')\n"
       "     +                        "
       (left-10 (si-arg-name var-spec))
       (left-10 reader)))
      (else (format-fortran-w-cont
         #t
         "      CALL ~a(SI_UNIT_NUM, ' ', ~a, ~a)\n"
         "     +                "
         (left-10 reader)
         (left-10 (si-arg-name var-spec))
         (left-10 (format #f "INT(~a)"
                  (write-dimen-size
                   (car (si-arg-dimen var-spec))))) ; A wild guess...
         )))))

(define (write-args l)
  (write-ftn-list l arg-col-out 4))

(define (header type decl)
  "Dumps header for fortran subroutine named FNAM with Subroutine
Information record DECL."

  (cond ((eq? type 'driver)
     (format #t "C $~a$
      PROGRAM ~a_~a\n\n"
         "Header:"
         (si-subname decl)
         type))
    (else
     (format #t "C $~a$
      SUBROUTINE ~a_~a ( SI_UNIT_NUM~a"
         "Header:"
         (si-subname decl)
         type
         (if (null? (si-args decl)) "" ","))
     (write-args (map car (si-args decl)))
     (format #t ")\n")))
  (format #t "
      IMPLICIT NONE

C Description
C -----------
C A ~a for subroutine ~a.  A reader for a
C subroutine is a subroutine which has the same arguments as said
C subroutine (except for an additional arg SI_UNIT_NUM containing a
C unit number), and reads from SI_UNIT_NUM to initialize all its
C arguments.  A writer is analogous.  A driver is a program which call
C the reader, call the subroutine, calls the writer, and repeats.\n"
      type (si-subname decl))

  (format #t "
C This file was initially generated by make-test-routines, but probably
C includes lots of hand tuning by ~a, so don't just
C regenerate it.

C Includes (listed before args because they might be needed)
C ----------------------------------------------------------\n"
          (getenv "USER"))

  (for-each (lambda (inc)
          (format #t "      INCLUDE '~a'\n" (si-incs-file-name inc)))
        (si-includes decl))
  (format #t "
C Arguments (After includes in case includes are needed).
C -------------------------------------------------------
      INTEGER*2       SI_UNIT_NUM\n")
  (if (eq? type 'dumper)
      (format #t "      INTEGER*2       SI_UNIT_OUT\n"))

  (dump-decls (si-args decl))

  (format #t "
C External (not all may be needed)
C --------------------------------\n")

  (if (eq? type 'reader)
      (format #t "      REAL*8    pff_rdreal
      INTEGER*4 pff_rdint
      LOGICAL   pff_rdlog
      EXTERNAL  pff_rdreal, pff_rdint, pff_rdlog\n"))

  (map (lambda (ext)
     (if (assoc (car ext) (si-args decl))
         (format #t "      EXTERNAL  ~a\n" (car ext))))
       (si-externals decl))
  (if (and (eq? type 'driver) (not (eq? '*void* (si-function-type decl))))
      (format #t "      EXTERNAL  ~a\n" (si-subname decl)))
  (format #t "
C Code
C ----\n")
  (if (not (eq? type 'driver))
      (format #t "
      If (SI_UNIT_NUM .LT. 1) GOTO 90000 ! Allows easy turning off...
\n")))

(define (dump-decls decl)
  "Writes out fortran declarations for arguments listed in Subroutine
Information argument declaration list DECL."

  (define (format-dimen dlist)
    (define (format-dimen-aux dlist)
      (cond ((null? dlist) ")\n")
        ((null? (cdr dlist)) (format #t "~a)\n" (car dlist)))
        (else (format #t "~a, " (car dlist))
          (format-dimen-aux (cdr dlist)))))
    (format #t "(")
    (format-dimen-aux dlist))

  (define (dump-decl rec)
    (define type-out (make-fmt-fcn "~15a"))
    (format #t "      ~a ~a"
        (type-out #f (si-conditioned-arg-type rec))
        (si-arg-name rec))
    (if (si-arg-dimen rec)
    (format-dimen (si-arg-dimen rec))
    (format #t "\n")))
  (for-each dump-decl decl))

(define (dump-reader decl)
  "Outputs fortran code for reading each argument listed in Subroutine
Information record DECL."
  (for-each (lambda (arg-spec)
          (if (not (assoc (si-arg-name arg-spec) (si-externals decl)))
          (read-var arg-spec)
          (format #t "C        ~a skipped because it's external.\n"
              (si-arg-name arg-spec))))
        (si-args decl)))

(define (dump-writer decl)
  "Outputs fortran code for writing each argument listed in Subroutine
Information record DECL."
  (for-each (lambda (arg-spec)
          (if (not (assoc (si-arg-name arg-spec) (si-externals decl)))
          (write-var arg-spec)
          (format #t "C        ~a skipped because it's external.\n"
              (si-arg-name arg-spec))))
        (si-args decl)))

(define (dump-driver decl)
  "Outputs call to reader, call to subroutine/function, and call to
writer."
  (format #t "
      SI_UNIT_NUM = 5 ! Read from stdin.
      SI_UNIT_OUT = 6 ! Write to stdout.
 1000 CONTINUE")
  (format #t "
      CALL ~a_reader ( SI_UNIT_NUM~a"
      (si-subname decl)
      (if (null? (si-args decl)) "" ","))
  (write-args (map car (si-args decl)))
  (format #t ")\n")

  (format #t "
      ~a ~a ("
      (if (eq? (si-function-type decl) '*void*) "CALL"
          (string-append (symbol->string (si-function-type decl))
                 " FUNCTION"))
      (si-subname decl))
  (write-args (map car (si-args decl)))
  (format #t ")\n")

  (format #t "
      CALL ~a_writer ( SI_UNIT_OUT~a"
      (si-subname decl)
      (if (null? (si-args decl)) "" ","))
  (write-args (map car (si-args decl)))
  (format #t ")\n")

  (format #t "
      GOTO 1000

90000 continue
      end\n"))

(define (trailer)
  "Writes out fortran trailer code - code for closing up a subroutine call."
  (format #t "
90000 continue
      return
      end\n"))

;;; Miscellaneous output routines:
(define (arg-col-out arg)
  "Writes out symbol ARG left justified in a 15 character field."
  (define arg-col-out-aux (make-fmt-fcn "~15a"))
  (arg-col-out-aux #t (symbol->string arg)))

(define (left-15 arg)
  "Writes out symbol ARG left justified in a 15 character field."
  (define arg-col-out-aux (make-fmt-fcn "~15a"))
  (arg-col-out-aux #f (if (symbol? arg) (symbol->string arg)
              arg)))

(define (left-10 arg)
  "Writes out symbol ARG left justified in a 10 character field."
  (define arg-col-out-aux (make-fmt-fcn "~10a"))
  (arg-col-out-aux #f (if (symbol? arg) (symbol->string arg)
              arg)))

(provide "si-lib")